home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / brklyprl.lha / Emulator / built_ins.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-04-14  |  20.1 KB  |  938 lines
  1.  
  2. /* Copyright (C) 1988, 1989 Herve' Touati, Aquarius Project, UC Berkeley */
  3.  
  4. /* Copyright Herve' Touati, Aquarius Project, UC Berkeley */
  5.  
  6. #include <stream.h>
  7. #include <sys/time.h>
  8. #include <sys/resource.h>
  9. #include <ctype.h>
  10. #include "tags.h"
  11. #include "instr.h"
  12. #include "hash_table.h"
  13. #include "string_table.h"
  14. #include "memory.h"
  15. #include "scan.h"
  16. #include "inst_args.h"
  17. #include "basics.h"
  18. #include "top_level.h"
  19. #include "main.h"
  20.  
  21. enum {
  22.   SHARED_COPY,
  23.   UNSHARED_COPY
  24.   };
  25.  
  26.  /* Copy instructions */
  27.  /* updates the "to" to point to the next available cell */
  28.  /* returns the copy */
  29. Cell CopyTerm(Cell term, CellPtr& to, int mode)
  30. {
  31.   CellPtr top_trail = TR;
  32.   register CellPtr first = to;
  33.   register CellPtr second = to;
  34.   *first++ = term;
  35.   while (second < first) {
  36.     Cell value = deref(*second);
  37.     switch (get_tag(value)) {
  38.     case TAGREF:
  39.       switch (mode) {
  40.       case UNSHARED_COPY:
  41.     if (cellp(value) < to || cellp(value) > second) {
  42.       *second = make_ptr(TAGREF, second);
  43.       Bind(value, *second++);
  44.     } else {
  45.       *second++ = value;
  46.     }
  47.     break;
  48.       case SHARED_COPY:
  49.     *second++ = value;
  50.     break;
  51.       }
  52.       break;
  53.     case TAGLIST:
  54.       *second++ = make_ptr(TAGLIST, first);
  55.       Cell* from = addr(value);
  56.       *first++ = *from++;
  57.       *first++ = *from;
  58.       break;
  59.     case TAGSTRUCT:
  60.       *second++ = make_ptr(TAGSTRUCT, first);
  61.       from = addr(value);
  62.       *first++ = *from++;
  63.       int i0 = get_int(*from);
  64.       *first++ = *from++;
  65.       for (int i = 0; i < i0; i++)
  66.     *first++ = *from++;
  67.       break;
  68.     case TAGCONST:
  69.       *second++ = value;
  70.       break;
  71.     }
  72.   }
  73.   CellPtr tr = top_trail;
  74.   CellPtr tr0 = TR;
  75.   for (; tr > tr0; tr--)
  76.     rvalue(*tr) = *tr;
  77.   TR = top_trail;
  78.   Cell result = *to;
  79.   to = first;
  80.   return result;
  81. }
  82.  
  83. /* just moves a block by offsetting the pointers by to - from */
  84.  /* since we do not represent structure arities as tagged objects */
  85.  /* we have to make sure in the structure case that */
  86.  /* the arity is correctly copied */
  87. Cell MoveTerm(Cell value, int block_length, CellPtr& to, int mode)
  88. {
  89.   register CellPtr p = addr(value);
  90.   register CellPtr q = to;
  91.   int offset = (char*) q - (char*) p;
  92.   for (int i = 0; i < block_length; i++) {
  93.     switch (get_tag(*p)) {
  94.     case TAGREF:
  95.       switch (mode) {
  96.       case UNSHARED_COPY:
  97.     *q++ = *p++ + offset;
  98.     break;
  99.       case SHARED_COPY:
  100.     *q++ = *p++;
  101.     break;
  102.       }
  103.       break;
  104.     case TAGLIST:
  105.       *q++ = *p++ + offset;
  106.       break;
  107.     case TAGSTRUCT:
  108.       *q++ = *p++ + offset;
  109.       break;
  110.     case TAGCONST:
  111.       *q++ = *p++;
  112.       break;
  113.     }
  114.   }
  115.   Cell result = make_ptr(get_tag(value), to);
  116.   to = q;
  117.   return result;
  118. }
  119.  
  120.   /* only the top level is transformed */
  121.   /* if the list contains lists, these sublists will still be lists */
  122.   /* if from is not a list, or something wrong happens, like the */
  123.   /* first element of the list is not an atom, returns 0 */
  124.  
  125. Cell SharedFromListToStruct(Cell val, CellPtr& to)
  126. {
  127.   if (get_tag(val) != TAGLIST || ! is_atom(car(val))) {
  128.     top_level_error("unexpected type in FromListToStruct");
  129.   }
  130.   register CellPtr target = to;
  131.   Cell atom = car(val);
  132.   Cell from = deref(cdr(val));
  133.   int arity = 0;
  134.   target += 2;
  135.   for (; get_tag(from) == TAGLIST; from = deref(cdr(from))) {
  136.     *target++ = car(from);
  137.     arity++;
  138.   }
  139.   if (from != NIL) {
  140.     top_level_error("Second Arg of Univ not NIL terminated");
  141.   }
  142.   if (arity == 0) {
  143.     return atom;
  144.   } else {
  145.     Cell result = make_ptr(TAGSTRUCT, to);
  146.     *to++ = make_atom(SCAN.atom_to_functor(get_id(atom), arity));
  147.     *to = make_int(arity);
  148.     to = target;
  149.     return result;
  150.   }
  151. }
  152.  
  153.   /* the inverse map of the previous one */
  154. Cell SharedFromStructToList(Cell val, CellPtr& to)
  155. {
  156.   if (get_tag(val) != TAGSTRUCT) {
  157.     top_level_error("Unexpected type in SharedFromStructToList");
  158.   }
  159.   register CellPtr origin = addr(val);
  160.   Cell atom = *origin++;
  161.   Cell result = make_ptr(TAGLIST, to);
  162.   *to++ = make_atom(SCAN.functor_to_atom(get_id(atom)));
  163.   *to++ = make_ptr(TAGLIST, to + 1);
  164.   int arity = get_int(*origin++);
  165.   for (int i = 0; i < arity; i++) {
  166.     *to++ = *origin++;
  167.     *to++ = make_ptr(TAGLIST, to + 1);
  168.   }
  169.   *(to - 1) = NIL;
  170.   return result;
  171. }
  172.  
  173. Cell Arithm(Cell Arg1, Cell OpCode, Cell Arg2)
  174. {
  175.   Arg1 = deref(Arg1);
  176.   Arg2 = deref(Arg2);
  177.   if (! is_int(Arg1) || ! is_int(Arg2) || ! is_atom(OpCode))
  178.     return NIL;
  179.   switch(*get_string(OpCode)) {
  180. #define use(ch,op,shift_before,shift_after)\
  181.   case 'ch':\
  182.     Arg1 = ((Arg1 shift_before) op Arg2) shift_after;\
  183.       return Arg1;
  184.     use(+,+,,) use(-,-,,) use(*,*,>>3,) use(/,/,,<< 3) use(m,%,,)
  185. #undef use
  186.   default:
  187.     return NIL;
  188.   }
  189. }
  190.   
  191. void bind_to_arithmetic_result(Cell Var, Cell result)
  192. {
  193.   if (result == NIL) 
  194.     top_level_error("error in arithmetic expression\n");
  195.   Var = deref(Var);
  196.   switch (get_tag(Var)) {
  197.   case TAGREF:
  198.     Bind(Var, result);
  199.     break;
  200.   case TAGCONST:
  201.     if (Var != result)
  202.       P = FP0;
  203.     break;
  204.   default:
  205.     top_level_error("error in arithmetic expression\n");
  206.     break;
  207.   }
  208. }
  209.   
  210. void Is4() 
  211. {
  212.   Cell result = Arithm(X[1], X[2], X[3]);
  213.   bind_to_arithmetic_result(X[0], result);
  214. }
  215.  
  216. Cell evaluate(Cell Expr)
  217. {
  218.   Expr = deref(Expr);
  219.   if (is_int(Expr)) return Expr;
  220.   switch (get_tag(Expr)) {
  221.   case TAGLIST:      // yes, C-Prolog does that for some reason
  222.     {
  223.       Cell value = car(Expr);
  224.       Expr = cdr(Expr);
  225.       return (Expr == NIL) ? evaluate(value) : NIL;
  226.     }
  227.   case TAGSTRUCT:
  228.     {
  229.       Cell op = *addr(Expr);
  230.       Cell expr1 = *(addr(Expr) + 2);
  231.       Cell expr2 = *(addr(Expr) + 3);
  232.       expr1 = evaluate(expr1);
  233.       expr2 = evaluate(expr2); 
  234.       return Arithm(expr1, op, expr2);
  235.     default:
  236.       return NIL;
  237.     }
  238.   }
  239. }
  240.  
  241. void Is2() 
  242. {
  243.   Cell result = evaluate(X[1]);
  244.   bind_to_arithmetic_result(X[0], result);
  245. }  
  246.  
  247.  /* clearly, this routine should only check for the minimum */
  248.  /* does not print more than BREADTH_LIMIT elements of a list or structure */
  249.  /* and does not go deeper than DEPTH_LIMIT levels of recursion */
  250.  
  251. enum {
  252.   WITH_QUOTES,
  253.   WITHOUT_QUOTES
  254.   };
  255.  
  256.  /* only a simple-minded implementation here */
  257. inline void print_quote_string(char* s, int quotes)
  258. {
  259.   if (isalnum(*s))
  260.     quotes = WITHOUT_QUOTES;
  261.   char* string = (quotes == WITH_QUOTES) ? "'" : "";
  262.   fprintf(stderr,"%s%s%s", string, s, string);
  263. }
  264.  
  265. void limited_write(CellPtr segment, Cell Var, int depth, int quotes)
  266. {  
  267.   Var = deref(Var);
  268.   if (depth >= DEPTH_LIMIT) {fprintf(stderr,"..."); return;}
  269.   switch (get_tag(Var)) {
  270.   case TAGREF:
  271.     if (segment == H0) {
  272.       if (cellp(Var) < E0)
  273.     fprintf(stderr,"H_%d", cellp(Var) - H0);
  274.       else
  275.     fprintf(stderr,"E_%d", cellp(Var) - E0);
  276.     } else {            /* reserved area in that case */
  277.       fprintf(stderr,"R_%d", cellp(Var) - R0);
  278.     }      
  279.     return;
  280.   case TAGCONST:
  281.     if (is_int(Var))
  282.       cerr << get_int(Var);
  283.     else
  284.       print_quote_string(get_string(Var), quotes);
  285.     return;
  286.   case TAGLIST:
  287.     fprintf(stderr,"[");
  288.     for (int breadth = 0; breadth < BREADTH_LIMIT; breadth++) {
  289.       limited_write(segment, car(Var), depth + 1, quotes);
  290.       Var = deref(cdr(Var));
  291.       if (get_tag(Var) == TAGLIST) {
  292.     fprintf(stderr,",");
  293.     continue;
  294.       } else if (Var == NIL) {
  295.     break;
  296.       } else {
  297.     fprintf(stderr,"|");
  298.     limited_write(segment, Var, depth + 1, quotes);
  299.     break;
  300.       } 
  301.     }
  302.     if (breadth == BREADTH_LIMIT) fprintf(stderr,"...");
  303.     fprintf(stderr,"]");
  304.     return;
  305.   case TAGSTRUCT:
  306.     {
  307.       Cell* ptr = addr(Var);
  308.       fprintf(stderr,"%s(", get_string(*ptr++));
  309.       int i0 = get_int(*ptr++);
  310.       int i = 0;
  311.       for (;;) {
  312.     limited_write(segment, *ptr++, depth + 1, quotes);
  313.     i++;
  314.     if (i >= i0) {cerr << ")"; return;}
  315.     if (i >= BREADTH_LIMIT) {cerr << "...)"; return;}
  316.     cerr << ",";
  317.       }
  318.     }
  319.   }
  320. }
  321.  
  322. void Write()
  323. {limited_write(H0, X[0], 0, WITHOUT_QUOTES);}
  324.  
  325.  
  326. void Writeq()
  327. {
  328.   limited_write(H0, X[0], 0, WITH_QUOTES);
  329. }
  330.  
  331. void write_term(Cell term)
  332. {limited_write(H0, term, 0, WITHOUT_QUOTES);}
  333.  
  334. int same(register Cell arg1, register Cell arg2) 
  335. {
  336.  top_of_the_loop:
  337.   arg1 = deref(arg1);
  338.   arg2 = deref(arg2);
  339.   if (arg1 == arg2) return UNIFY_SUCCESS;
  340.   if (get_tag(arg1) != get_tag(arg2)) return UNIFY_FAIL;
  341.   switch(get_tag(arg1)) {
  342.   case TAGLIST:
  343.     {
  344.       CellPtr S1 = addr(arg1);
  345.       CellPtr S2 = addr(arg2);
  346.       if (same(S1[0], S2[0]) == UNIFY_FAIL) return UNIFY_FAIL;
  347.       arg1 = S1[1];
  348.       arg2 = S2[1];
  349.       goto top_of_the_loop;
  350.     }
  351.   case TAGSTRUCT:
  352.     {
  353.       CellPtr S1 = addr(arg1);
  354.       CellPtr S2 = addr(arg2);
  355.       if (S1[0] != S2[0]) return UNIFY_FAIL;
  356.       int i0 = get_int(S1[1]) + 2;
  357.       for (int i = 2; i < i0; i++)
  358.     if (same(S1[i], S2[i]) == UNIFY_FAIL) return UNIFY_FAIL;
  359.       break;
  360.     }
  361.   default:
  362.     return UNIFY_FAIL;
  363.   }
  364. }
  365.  
  366. void Same()
  367. {
  368.   if (same(X[0], X[1]) == UNIFY_FAIL)
  369.     P = FP0;
  370. }
  371. void Nsame()
  372. {
  373.   if (same(X[0], X[1]) == UNIFY_SUCCESS)
  374.     P = FP0;
  375. }
  376.  
  377. #define BUFFER_SIZE 80
  378. static char buffer[BUFFER_SIZE];
  379.  
  380.  /* initially forgot the case of a list of variables */
  381. enum {NAME_ATOM, NAME_REF};
  382.  
  383. void name(Cell val1, Cell val2)
  384. {
  385.   static char* error_msg = "Illegal call to built-in name(atom, ascii list)";
  386.   val1 = deref(val1);
  387.   val2 = deref(val2);
  388.   Cell list, atom;
  389.   char* p;
  390.   switch (get_tag(val1)) {
  391.   case TAGCONST:
  392.     p = get_string(val1);
  393.     if (is_int(val1)) {
  394.       sprintf(buffer, "%d", get_int(val1));
  395.       p = buffer;
  396.     }
  397.     list = make_ptr(TAGLIST, H);
  398.     for (; *p; p++) {
  399.       *H++ = make_int(*p);
  400.       *H++ = make_ptr(TAGLIST, H + 1);
  401.     }
  402.     *(H - 1) = NIL;
  403.     if (! unify(list, val2))
  404.       P = FP0;
  405.     break;
  406.   case TAGREF:
  407.     if (get_tag(val2) != TAGLIST && val2 != NIL) {
  408.       top_level_error(error_msg);
  409.     }
  410.     p = buffer;
  411.     while (get_tag(val2) == TAGLIST) {
  412.       Cell var = car(val2);
  413.       int ch;
  414.       if (is_int(var) && isascii(ch = get_int(var))) {
  415.     *p++ = ch;
  416.       } else {
  417.     top_level_error(error_msg);
  418.       }
  419.       val2 = deref(cdr(val2));
  420.     }
  421.     if (val2 != NIL) {
  422.       top_level_error(error_msg);
  423.     }
  424.     *p = '\0';
  425.     atom = make_atom(SCAN.intern(buffer));
  426.     if (! unify(atom, val1))
  427.       P = FP0;
  428.     break;
  429.   default:
  430.     top_level_error(error_msg);
  431.     break;
  432.   }
  433. }
  434.  
  435. void Name() 
  436. {
  437.   name(X[0], X[1]);
  438. }
  439.  
  440. int list_length(Cell list)
  441. {
  442.    int l = 0;
  443.    while (get_tag(list) == TAGLIST) {
  444.      l++;
  445.      list = deref(cdr(list));
  446.    }
  447.    return l;
  448. }
  449.  
  450. void length(Cell val1, Cell val2)
  451. {
  452.    val1 = deref(val1);
  453.    val2 = deref(val2);
  454.    if (val1 == NIL || get_tag(val1) == TAGLIST) {
  455.      Cell len = list_length(val1);
  456.      if (! unify(make_int(len), val2))
  457.        P = FP0;
  458.    } else if (get_tag(val1) == TAGREF) {
  459.      Bind(val1, NIL);
  460.      if (! unify(make_int(0), val2))
  461.        P = FP0;
  462.    } else {
  463.       P = FP0;
  464.    }
  465. }
  466.  
  467. void Length()
  468. {
  469.   length(X[0], X[1]);
  470. }
  471.  
  472.  /* time in ms */
  473. Cell statistics()
  474. {
  475.   struct rusage info;
  476.   extern void getrusage(...);
  477.   getrusage(RUSAGE_SELF, &info);
  478.   int i = info.ru_utime.tv_sec * 1000 + info.ru_utime.tv_usec / 1000;
  479.   return make_int(i);
  480. }
  481.  
  482. void Statistics()
  483. {
  484.   if (! unify(X[0], statistics()))
  485.     P = FP0;
  486. }
  487.  
  488. void univ(Cell val1, Cell val2)
  489. {
  490.   val1 = deref(val1);
  491.   val2 = deref(val2);
  492.   Cell new_list;
  493.   switch (get_tag(val1)) {
  494.   case TAGSTRUCT:
  495.     Cell* NewH = H;
  496.     val1 = SharedFromStructToList(val1, NewH);
  497. #ifdef WITH_GC
  498.     if (NewH >= HMAXHARD)
  499.       top_level_error("Heap overflow");
  500. #else
  501.     if (NewH - H0 > memory_sizes[HEAP_SIZE])
  502.       top_level_error("Heap overflow");
  503. #endif
  504.     H = NewH;
  505.     if (! unify(val1, val2))
  506.       P = FP0;
  507.     break;
  508.   case TAGLIST:
  509.     new_list = make_ptr(TAGLIST, H);
  510.     *H++ = make_atom(SCAN.functor_to_atom(get_id(LIST_FUNCTOR)));
  511.     *H++ = make_ptr(TAGLIST, H + 1);
  512.     *H++ = car(val1);
  513.     *H++ = make_ptr(TAGLIST, H + 1);
  514.     *H++ = cdr(val1);
  515.     *H++ = NIL;
  516.     if (! unify(new_list, val2))
  517.       P = FP0;
  518.     break;
  519.   case TAGCONST:
  520.     new_list = make_ptr(TAGLIST, H);
  521.     *H++ = val1;
  522.     *H++ = NIL;
  523.     if (! unify(new_list, val2))
  524.       P = FP0;
  525.     break;
  526.   case TAGREF:
  527.     {
  528.       if (val2 == NIL) {
  529.     Bind(val1, NIL);
  530.     return;
  531.       }
  532.       if (get_tag(val2) != TAGLIST) {
  533.     P = FP0;
  534.     return;
  535.       }
  536.       int arity = list_length(val2) - 1;
  537.       Cell atom = car(val2);
  538.       if (get_tag(atom) != TAGCONST || (is_int(atom) && arity != 0)) {
  539.     P = FP0;
  540.     return;
  541.       }
  542.       if (is_int(atom)) {
  543.     Bind(val1, atom);
  544.     return;
  545.       }
  546.       Cell* NewH = H;
  547.       val2 = SharedFromListToStruct(val2, NewH);
  548. #ifdef WITH_GC
  549.       if (NewH >= HMAXHARD)
  550.     top_level_error("Heap overflow");
  551. #else
  552.       if (NewH - H0 > memory_sizes[HEAP_SIZE])
  553.     top_level_error("Heap overflow");
  554. #endif
  555.       H = NewH;
  556.       Bind(val1, val2);
  557.     }
  558.     break;
  559.   }
  560. }
  561.  
  562. void Univ()
  563. {
  564.   univ(X[0], X[1]);
  565. }
  566.  
  567. void Tell()
  568. {}
  569.  
  570. void Told()
  571. {}
  572.  
  573. void Read()
  574. {}
  575.  
  576. void functor(Cell val1, Cell val2, Cell val3)
  577. {
  578.   val1 = deref(val1);
  579.   val2 = deref(val2);
  580.   val3 = deref(val3);
  581.   Cell atom, arity;
  582.   switch (get_tag(val1)) {
  583.   case TAGSTRUCT:
  584.     atom = addr(val1)[0];
  585.     atom = make_atom(SCAN.functor_to_atom(get_id(atom)));
  586.     arity = addr(val1)[1];
  587.     if (! unify(atom, val2)) {P = FP0; return;}
  588.     if (! unify(arity, val3)) {P = FP0; return;}
  589.     break;
  590.   case TAGLIST:
  591.     atom = make_atom(SCAN.functor_to_atom(get_id(LIST_FUNCTOR)));
  592.     if (! unify(atom, val2)) {P = FP0; return;}
  593.     if (! unify(make_int(2), val3)) {P = FP0; return;}
  594.     break;
  595.   case TAGCONST:
  596.     if (! unify(val1, val2)) {P = FP0; return;}
  597.     if (! unify(make_int(0), val3)) {P = FP0; return;}
  598.     break;
  599.   case TAGREF:
  600.     if (! is_int(val3)) {P = FP0; return;}
  601.     if (is_int(val2) && get_int(val3) == 0) {
  602.       Bind(val1, val2);
  603.       return;
  604.     }
  605.     if (is_atom(val2)) {
  606.       int i0 = get_int(val3);
  607.       Bind(val1, make_ptr(TAGSTRUCT, H));
  608.       *H++ = make_atom(SCAN.atom_to_functor(get_id(val2), i0));
  609.       *H++ = val3;
  610.       for (int i = 0; i < i0; i++)
  611.     *H++ = make_ptr(TAGREF, H);
  612.       return;
  613.     }
  614.     P = FP0;
  615.     break;
  616.   default:
  617.     P = FP0;
  618.   }
  619. }
  620.  
  621. void Functor()
  622. {
  623.   functor(X[0], X[1], X[2]);
  624. }
  625.  
  626. void arg(Cell val1, Cell val2, Cell val3)
  627. {
  628.   val1 = deref(val1);
  629.   val2 = deref(val2);
  630.   if (! is_int(val1)) {P = FP0; return;}
  631.   int index = get_int(val1);
  632.   switch (get_tag(val2)) {
  633.   case TAGSTRUCT:
  634.     int arity = get_int(addr(val2)[1]);
  635.     if (! unify(addr(val2)[index + 1], val3))
  636.       P = FP0;
  637.     break;
  638.   case TAGLIST:
  639.     if (! unify(addr(val2)[index - 1], val3))
  640.       P = FP0;
  641.     break;
  642.   default:
  643.     P = FP0;
  644.     break;
  645.   }
  646. }
  647.  
  648. void Arg()
  649. {
  650.   arg(X[0], X[1], X[2]);
  651. }
  652. /*
  653.  * We implement here a weak version of assert / retract 
  654.  * We allocate a reserved area of memory in which
  655.  * we store entries on an atom or integer.
  656.  * Set copies the term into this memory area, while Access
  657.  * copies it back to the global stack (heap), and unifies it
  658.  * with its argument. No garbage collection is provided.
  659.  * No garbage is generated if only atoms and integers are used.
  660.  */
  661.  
  662. static HashTable ValueTable;
  663. static HashTable SizeTable;
  664.  
  665. void set(Cell key, Cell term)
  666. {
  667.   Cell value;
  668.   int size;
  669.   term = deref(term);
  670.   switch (get_tag(term)) {
  671.   case TAGREF:
  672.   case TAGLIST:
  673.   case TAGSTRUCT:
  674.     Cell* NewR = R;
  675.     value = CopyTerm(term, NewR, UNSHARED_COPY);
  676.     size = NewR - R;
  677.     R = NewR;
  678.     if (R - R0 > memory_sizes[RESERVED_SIZE]) {
  679.       top_level_error("No more space in assert space");
  680.     }
  681.     break;
  682.   case TAGCONST:
  683.     value = term;
  684.     size = 0;
  685.     break;
  686.   }
  687.   ValueTable.bind(key, value);
  688.   SizeTable.bind(key, size);
  689. }
  690.  
  691. void Set()
  692. {
  693.   set(X[0], X[1]);
  694. }
  695.  
  696. void access(Cell key, Cell term)
  697. {
  698.   Cell value = ValueTable.get(key);
  699.   if (ValueTable.get_status() == HASH_MISS) {
  700.     write_term(key); cerr << ": ";
  701.     top_level_error("accessed before set");
  702.   }
  703.   if (get_tag(value) != TAGCONST) {
  704.     int size = SizeTable.get(key);
  705. #ifdef WITH_GC
  706.     if (size >= (HMAXSOFT - H)) {
  707.       if (size >= memory_sizes[HEAP_SIZE] - (H2 - H0))
  708.     top_level_error("heap overflow");
  709.       Cell* NewH = H2;
  710.       value = MoveTerm(value, size, NewH, UNSHARED_COPY);
  711.       H2 = NewH;
  712.     } else {
  713.       Cell* NewH = H;
  714.       value = MoveTerm(value, size, NewH, UNSHARED_COPY);
  715.       H = NewH;
  716.     }
  717.   }
  718. #else
  719.     if (H - H0 > memory_sizes[HEAP_SIZE] - size) {
  720.       top_level_error("heap overflow");
  721.     }
  722.     Cell* NewH = H;
  723.     value = MoveTerm(value, size, NewH, UNSHARED_COPY);
  724.     H = NewH;
  725.   }
  726. #endif
  727.   if (! unify(term, value))
  728.     P = FP0;
  729. }
  730.  
  731. void Access()
  732. {
  733.   access(X[0], X[1]);
  734. }
  735.  
  736. Cell assert_address_and_size(Cell key, int& size)
  737. {
  738.   Cell value = ValueTable.get(key);
  739.   if (ValueTable.get_status() == HASH_MISS) {
  740.     write_term(key); cerr << ": ";
  741.     top_level_error("accessed before set");
  742.   }
  743.   size = (get_tag(value) != TAGCONST) ? SizeTable.get(key) : 1;
  744.   return value;
  745. }
  746.   
  747.  /* **************************************** */
  748.  /* The following is for the CALL built-in */
  749.  /* **************************************** */
  750.  
  751. /* given a string, of the form "proc/arity" */
  752. /* finds the starting address in the code of the procedure */
  753. static Instr* get_procedure_addr(int name)
  754. {
  755.   int addr = instr_args[ARG_PROC]->update(get_id(name));
  756.   if (addr == 0) return 0;
  757.   return (Instr*) addr;
  758. }
  759.  
  760. /* given a string, of the form "proc/arity" */
  761. /* finds the built-in number that matches it */
  762. /* returns -1 if none. Used by Call */
  763. static PF get_built_in(int name)
  764. {
  765.   return instr_args[ARG_BUILTIN]->get_exec(get_id(name));
  766. }
  767.  
  768.  /* the way this is implemented is as follows: a call(X) is compiled */
  769.  /* into a CALL CALL/1,N or an EXECUTE_PROC CALL/1. THe call/1 routine */
  770.  /* is predefined (it starts at address -4) and contains only one */
  771.  /* instruction, namely ESCAPE CALL/1. Therefore, when the escape is */
  772.  /* executed, the environment for the procedure is already set up. The */
  773.  /* only thing left to do is to load the argument registers and */
  774.  /* execute the routine. Something special has to be done if the arity */
  775.  /* is 9 or more. Right now, just put a trap  */
  776.  
  777. void metacall(Cell term)
  778. {
  779.   int i, arity;
  780.   Cell name;
  781.   term = deref(term);
  782.   if (get_tag(term) == TAGSTRUCT) {
  783.     name = *addr(term);
  784.     arity = get_int(addr(term)[1]);
  785.   } else if (is_atom(term)) {
  786.     name = make_atom(SCAN.atom_to_functor(term, 0));
  787.     arity = 0;
  788.   } else {
  789.     P = FP0;
  790.     return;
  791.   }
  792.   if (arity > NUMBER_OF_REGISTERS) {
  793.     top_level_error("Metacalls with large arities not supported");
  794.   }
  795.   for (i = 0; i < arity; i++)
  796.     X[i] = addr(term)[i + 2];
  797.   PF function = get_built_in(name);
  798.   if (function != 0) {
  799.     (*function)();
  800.     return;
  801.   }
  802.   Instr* instr = get_procedure_addr(name);
  803.   if (instr != 0) {
  804.     P = instr;
  805.     return;
  806.   }
  807.   cerr << (char*) name << ": ";
  808.   top_level_error("undefined procedure");
  809. }
  810.  
  811. void Metacall() 
  812. {
  813.   metacall(X[0]);
  814. }
  815.  
  816. void print_args(int arity)
  817. {
  818.   int i;
  819.   int max = arity - 1;
  820.  
  821.   if (arity == 0) return;
  822.   printf("(");
  823.   for (i = 0; i < max; i++) 
  824.     { write_term(*(X + i)); printf(","); }
  825.   write_term(*(X + i));
  826.   printf(")");
  827. }
  828.  
  829. void Nl()
  830. {
  831.   cerr << "\n";
  832. }
  833.  
  834. void Var()
  835. {
  836.   if (get_tag(deref(X[0])) != TAGREF) P = FP0;
  837. }
  838.  
  839. void Integer()
  840. {
  841.   if (! is_int(deref(X[0]))) P = FP0;
  842. }
  843.  
  844. void Number()
  845. {
  846.   if (! is_int(deref(X[0]))) P = FP0;
  847. }
  848.  
  849. void Atom()
  850. {
  851.   if (! is_atom(deref(X[0]))) P = FP0;
  852. }
  853.  
  854. #define use(Function,op)\
  855. void Function()\
  856. {\
  857.   Cell Arg1 = deref(X[0]);\
  858.   Cell Arg2 = deref(X[1]);\
  859.   if (! is_int(Arg1) || ! is_int(Arg2))\
  860.     P = FP0;\
  861.   if (! (Arg1 op Arg2))\
  862.     P = FP0;\
  863. }
  864. use(Gt,>) use(Ge,>=) use(Le,<=) use(Lt,<) use(Neq,!=)
  865. #undef use
  866.  
  867. void Assert(){}
  868. void Retract(){}
  869.  
  870. void Success()
  871. {
  872.   top_level_success();
  873. }
  874.  
  875. void Failure()
  876. {
  877.   top_level_failure();
  878. }
  879.  
  880.  /* this is not in general compatible with CProlog */
  881.  /* it gives only what is needed in practice: */
  882.  /* an arbitrary total order on Prolog values */
  883. int compare_terms(Cell arg1, Cell arg2)
  884. {
  885.   arg1 = deref(arg1);
  886.   arg2 = deref(arg2);
  887.   return (arg1 > arg2);
  888. }
  889.  
  890. void Gtvar()
  891. {
  892.   if (! compare_terms(X[0], X[1]))
  893.     P = FP0;
  894. }
  895.  
  896. void Ltvar()
  897. {
  898.   if (compare_terms(X[0], X[1]))
  899.     P = FP0;
  900. }
  901.  
  902. void Put()
  903. {
  904.   fprintf(stderr,"%c", get_int(X[0]));
  905. }
  906.  
  907. void Neqarithm()
  908. {
  909.   Cell val1 = deref(X[0]);
  910.   Cell val2 = deref(X[1]);
  911.   if (! is_int(val1) || ! is_int(val2)) {
  912.     top_level_error("Integer value expected in =\=");
  913.   }
  914.   if (val1 == val2)
  915.     P = FP0;
  916. }
  917.  
  918. void RandomInteger()
  919. {
  920.   extern int random(...);
  921.   extern int srandom(...);
  922.  
  923.   Cell val = deref(X[0]);
  924.   switch (get_tag(val)) {
  925.   case TAGREF:
  926.     Bind(val, make_int(random()));
  927.     break;
  928.   case TAGCONST:
  929.     if (! is_int(val))
  930.       top_level_error("Integer or Variable expected in random\n");
  931.     srandom(get_int(val));
  932.     break;
  933.   default:
  934.     top_level_error("Integer or Variable expected in random\n");
  935.     break;
  936.   }
  937. }
  938.